home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue45 / Clinic / Server / Server_TLB.pas next >
Encoding:
Pascal/Delphi Source File  |  2000-11-02  |  5.8 KB  |  162 lines
  1. unit Server_TLB;
  2.  
  3. // ************************************************************************ //
  4. // WARNING                                                                  //
  5. // -------                                                                  //
  6. // The types declared in this file were generated from data read from a     //
  7. // Type Library. If this type library is explicitly or indirectly (via      //
  8. // another type library referring to this type library) re-imported, or the //
  9. // 'Refresh' command of the Type Library Editor activated while editing the //
  10. // Type Library, the contents of this file will be regenerated and all      //
  11. // manual modifications will be lost.                                       //
  12. // ************************************************************************ //
  13.  
  14. // PASTLWTR : $Revision:   1.11.1.63  $
  15. // File generated on 31/08/98 09:25:33 from Type Library described below.
  16.  
  17. // ************************************************************************ //
  18. // Type Lib: D:\BUG\CORBA\Server.tlb
  19. // IID\LCID: {6B0BEBC0-40B4-11D2-8684-0020182CD6A0}\0
  20. // Helpfile: 
  21. // HelpString: Server Library
  22. // Version:    1.0
  23. // ************************************************************************ //
  24.  
  25. interface
  26.  
  27. uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL, SysUtils, CORBAObj, OrbPas, CorbaStd;
  28.  
  29. // *********************************************************************//
  30. // GUIDS declared in the TypeLibrary. Following prefixes are used:      //
  31. //   Type Libraries     : LIBID_xxxx                                    //
  32. //   CoClasses          : CLASS_xxxx                                    //
  33. //   DISPInterfaces     : DIID_xxxx                                     //
  34. //   Non-DISP interfaces: IID_xxxx                                      //
  35. // *********************************************************************//
  36. const
  37.   LIBID_Server: TGUID = '{6B0BEBC0-40B4-11D2-8684-0020182CD6A0}';
  38.   IID_ITest: TGUID = '{6B0BEBC1-40B4-11D2-8684-0020182CD6A0}';
  39.   CLASS_Test: TGUID = '{6B0BEBC3-40B4-11D2-8684-0020182CD6A0}';
  40. type
  41.  
  42. // *********************************************************************//
  43. // Forward declaration of interfaces defined in Type Library            //
  44. // *********************************************************************//
  45.   ITest = interface;
  46.   ITestDisp = dispinterface;
  47.  
  48. // *********************************************************************//
  49. // Declaration of CoClasses defined in Type Library                     //
  50. // (NOTE: Here we map each CoClass to its Default Interface)            //
  51. // *********************************************************************//
  52.   Test = ITest;
  53.  
  54.  
  55. // *********************************************************************//
  56. // Interface: ITest
  57. // Flags:     (4416) Dual OleAutomation Dispatchable
  58. // GUID:      {6B0BEBC1-40B4-11D2-8684-0020182CD6A0}
  59. // *********************************************************************//
  60.   ITest = interface(IDispatch)
  61.     ['{6B0BEBC1-40B4-11D2-8684-0020182CD6A0}']
  62.     function Get_DateAndTime: TDateTime; safecall;
  63.     property DateAndTime: TDateTime read Get_DateAndTime;
  64.   end;
  65.  
  66. // *********************************************************************//
  67. // DispIntf:  ITestDisp
  68. // Flags:     (4416) Dual OleAutomation Dispatchable
  69. // GUID:      {6B0BEBC1-40B4-11D2-8684-0020182CD6A0}
  70. // *********************************************************************//
  71.   ITestDisp = dispinterface
  72.     ['{6B0BEBC1-40B4-11D2-8684-0020182CD6A0}']
  73.     property DateAndTime: TDateTime readonly dispid 1;
  74.   end;
  75.  
  76.   TTestStub = class(TCorbaDispatchStub, ITest)
  77.   public
  78.     function Get_DateAndTime: TDateTime; safecall;
  79.   end;
  80.  
  81.   TTestSkeleton = class(TCorbaSkeleton)
  82.   private
  83.     FIntf: ITest;
  84.   public
  85.     constructor Create(const InstanceName: string; const Impl: IUnknown); override;
  86.     procedure GetImplementation(out Impl: IUnknown); override; stdcall;
  87.   published
  88.     procedure Get_DateAndTime(const InBuf: IMarshalInBuffer; Cookie: Pointer);
  89.   end;
  90.  
  91.   CoTest = class
  92.     class function Create: ITest;
  93.     class function CreateRemote(const MachineName: string): ITest;
  94.   end;
  95.  
  96.   TTestCorbaFactory = class
  97.     class function CreateInstance(const InstanceName: string): ITest;
  98.   end;
  99.  
  100. implementation
  101.  
  102. uses ComObj;
  103.  
  104. { TTestStub }
  105.  
  106. function TTestStub.Get_DateAndTime: TDateTime;
  107. var
  108.   OutBuf: IMarshalOutBuffer;
  109.   InBuf: IMarshalInBuffer;
  110. begin
  111.   FStub.CreateRequest('Get_DateAndTime', True, OutBuf);
  112.   FStub.Invoke(OutBuf, InBuf);
  113.   Result := TDateTime(InBuf.GetDouble);
  114. end;
  115.  
  116. { TTestSkeleton }
  117.  
  118. constructor TTestSkeleton.Create(const InstanceName: string; const Impl: IUnknown);
  119. begin
  120.   inherited;
  121.   inherited InitSkeleton('Test', InstanceName, 'IDL:Server/ITest:1.0', tmMultiThreaded, True);
  122.   FIntf := Impl as ITest;
  123. end;
  124.  
  125. procedure TTestSkeleton.GetImplementation(out Impl: IUnknown);
  126. begin
  127.   Impl := FIntf;
  128. end;
  129.  
  130. procedure TTestSkeleton.Get_DateAndTime(const InBuf: IMarshalInBuffer; Cookie: Pointer);
  131. var
  132.   OutBuf: IMarshalOutBuffer;
  133.   Retval: TDateTime;
  134. begin
  135.   Retval := FIntf.Get_DateAndTime;
  136.   FSkeleton.GetReplyBuffer(Cookie, OutBuf);
  137.   OutBuf.PutDouble(Double(Retval));
  138. end;
  139.  
  140. class function CoTest.Create: ITest;
  141. begin
  142.   Result := CreateComObject(CLASS_Test) as ITest;
  143. end;
  144.  
  145. class function CoTest.CreateRemote(const MachineName: string): ITest;
  146. begin
  147.   Result := CreateRemoteComObject(MachineName, CLASS_Test) as ITest;
  148. end;
  149.  
  150. class function TTestCorbaFactory.CreateInstance(const InstanceName: string): ITest;
  151. begin
  152.   Result := CorbaFactoryCreateStub('IDL:Server/TestFactory:1.0', 'Test',
  153.     InstanceName, '', ITest) as ITest;
  154. end;
  155.  
  156. initialization
  157.   CorbaStubManager.RegisterStub(ITest, TTestStub);
  158.   CorbaInterfaceIDManager.RegisterInterface(ITest, 'IDL:Server/ITest:1.0');
  159.   CorbaSkeletonManager.RegisterSkeleton(ITest, TTestSkeleton);
  160.  
  161. end.
  162.